unit IconMain;

interface

uses
  Windows, ActiveX, ComObj, ShlObj;

type
  TPackType = (ptDesign, ptDesignRun, ptNone, ptRun);

  TIconHandler = class(TComObject, IExtractIcon, IPersistFile)
  private
    FFileName: string;
    function GetPackageType: TPackType;
  protected
// IExtractIcon methods
    function GetIconLocation(uFlags: UINT; szIconFile: LPWSTR; cchMax: UINT; out piIndex: Integer; out pwFlags: UINT): HResult; stdcall;
    function Extract(pszFile: LPCWSTR; nIconIndex: UINT; out phiconLarge, phiconSmall: HICON; nIconSize: UINT): HResult; stdcall;
// IPersist method
    function GetClassID(out classID: TCLSID): HResult; stdcall;
// IPersistFile methods
    function IsDirty: HResult; stdcall;
    function Load(pszFileName: POleStr; dwMode: Longint): HResult; stdcall;
    function Save(pszFileName: POleStr; fRemember: BOOL): HResult; stdcall;
    function SaveCompleted(pszFileName: POleStr): HResult; stdcall;
    function GetCurFile(out pszFileName: POleStr): HResult; stdcall;
  end;

  TIconHandlerFactory = class(TComObjectFactory)
  protected
    function GetProgID: string; override;
    procedure ApproveShellExtension(Register: Boolean; const ClsID: string); virtual;
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

implementation

uses
  SysUtils, ComServ, Registry, Vcl.Dialogs;
{ TIconHandler }

procedure PackInfoProc(const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer);
begin
// we don't need to implement this procedure because we are only
// interested in package flags, not contained units and required pkgs.
end;

function TIconHandler.GetPackageType: TPackType;
var
  PackMod: HMODULE;
  PackFlags: Integer;
begin
// Since we only need to get into the package's resources,
// LoadLibraryEx with LOAD_LIBRARY_AS_DATAFILE provides a speed-
// efficient means for loading the package.
  PackMod := LoadLibraryEx(PChar(FFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
  if PackMod = 0 then
  begin
    Result := ptNone;
    Exit;
  end;
  try
    GetPackageInfo(PackMod, nil, PackFlags, PackInfoProc);
  finally
    FreeLibrary(PackMod);
  end;
// mask off all but design and run flags, and return result
  case PackFlags and (pfDesignOnly or pfRunOnly) of
    pfDesignOnly:
      Result := ptDesign;
    pfRunOnly:
      Result := ptRun;
    pfDesignOnly or pfRunOnly:
      Result := ptDesignRun;
  else
    Result := ptNone;
  end;
end;
{ TIconHandler.IExtractIcon }

function TIconHandler.GetIconLocation(uFlags: UINT; szIconFile: LPWSTR; cchMax: UINT; out piIndex: Integer; out pwFlags: UINT): HResult;
begin
  pwFlags := GIL_DONTCACHE or GIL_NOTFILENAME;
  Result := S_OK;
end;

function TIconHandler.Extract(pszFile: LPCWSTR; nIconIndex: UINT; out phiconLarge, phiconSmall: HICON; nIconSize: UINT): HResult;
begin
// This method only needs to be implemented if the icon is stored in
// some type of user-defined data format. Since our icon is in a
// plain old DLL, we just return S_FALSE.
  ShowMessage(FFileName);
  phiconLarge := LoadIcon(HInstance, 'Icon_1');
  phiconSmall := LoadIcon(HInstance, 'Icon_2');
  Result := S_OK;
end;
{ TIconHandler.IPersist }

function TIconHandler.GetClassID(out classID: TCLSID): HResult;
begin
// this method is not called for icon handlers
  Result := E_NOTIMPL;
end;
{ TIconHandler.IPersistFile }

function TIconHandler.IsDirty: HResult;
begin
// this method is not called for icon handlers
  Result := S_FALSE;
end;

function TIconHandler.Load(pszFileName: POleStr; dwMode: Longint): HResult;
begin
// this method is called to initialized the icon handler shell
// extension. We must save the file name which is passed in pszFileName
  FFileName := pszFileName;
  Result := S_OK;
end;

function TIconHandler.Save(pszFileName: POleStr; fRemember: BOOL): HResult;
begin
// this method is not called for icon handlers
  Result := E_NOTIMPL;
end;

function TIconHandler.SaveCompleted(pszFileName: POleStr): HResult;
begin
// this method is not called for icon handlers
  Result := E_NOTIMPL;
end;

function TIconHandler.GetCurFile(out pszFileName: POleStr): HResult;
begin
// this method is not called for icon handlers
  Result := E_NOTIMPL;
end;
{ TIconHandlerFactory }

function TIconHandlerFactory.GetProgID: string;
begin
// ProgID not required for context menu shell extension
  Result := '';
end;

procedure TIconHandlerFactory.UpdateRegistry(Register: Boolean);
var
  ClsID: string;
begin
  ClsID := GUIDToString(classID);
  inherited UpdateRegistry(Register);
  ApproveShellExtension(Register, ClsID);
  if Register then
  begin
// must register .bpl as a file type
    CreateRegKey('.tsn', '', 'TisnFile');
// register this DLL as an icon handler for .bpl files
    CreateRegKey('TisnFile\ShellEx\IconHandler', '', ClsID);
  end
  else
  begin
    DeleteRegKey('.tsn');
    DeleteRegKey('TisnFile\ShellEx\IconHandler');
  end;
end;

procedure TIconHandlerFactory.ApproveShellExtension(Register: Boolean; const ClsID: string);
// This registry entry is required in order for the extension to
// operate correctly under Windows NT.
const
  SApproveKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved';
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    if not OpenKey(SApproveKey, True) then
      Exit;
    if Register then
      WriteString(ClsID, Description)
    else
      DeleteValue(ClsID);
  finally
    Free;
  end;
end;

const
  CLSID_IconHandler: TGUID = '{ED6D2F60-DA7C-11D0-A9BF-90D146FC32B3}';

initialization
  TIconHandlerFactory.Create(ComServer, TIconHandler, CLSID_IconHandler, 'DDG_IconHandler', 'DDG Icon Handler Shell Extension Example', ciMultiInstance, tmApartment);

end.

